Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/MCQUAY1/TDB601.PAS

Pascal/Delphi Source File | 1993-10-14 | 37KB | 1,284 lines

(******************************************
 Turbo Pascal / dBase III,III+,IV Interface
 TPDB
 McQuay Technologies
 Copyright 1988,89,90,91,92
 Version 6.01
 1/1/92
 ***************************************)
{$R-,S-,I-,F-,V-,B-,N-}
unit tdb601;
interface
uses dos,fileio6,frte,utils;

  const
     db_errorcode : word = 0;
     db_doserrorcode : word = 0;
     dbe_errorcode : word = 0;
     DB_TOP = 1;
     dbEnhance : boolean = false;
         MaxFields = 135;              {128 + 7 forcefields}
         DB_errortrap : boolean = true;

{-------------------------------------------------------------------------}
    type
        TPathName = string[64];
        TFieldName = array[1..11] of char;
        TFieldDescript = record
                        FieldName: TFieldName; {   dBase's field name             }
                        FieldType:char;           {   dBase filed type C = char      }
                                                                            {     N = numeric, L = Logical,    }
                                                                            {     D = Date, M = Memo           }
                        FieldLength:byte;         {   Length of field                }
                        Decimals:byte;            {   Number of decimal places       }
                        Inset:word;            {   Offset of field into record    }
                 end;
        TFields = array[1..MaxFields] of TFieldDescript;
        PFields = ^TFields;


        {.............................}
        TdbStructure =
            record
                FileName:TPathName;   { Filename of database file (path)     }
                TurboFile : ^file;
                Status:Tfilestatus;         { Status of file - open or unknown no  }
                                                                     {   Turbo dBase routine sets this to   }
                                                                     {   closed.  A structure returned with }
                                                                     {   a Query is unknown, otherwise fopen.}
                version:byte;              {   dBase version file was created with. }
        date: record
          year,month,day:byte;     { Date file was last edited.  Turbo    }
          end;                     {   dBase routines DO NOT update this. }
        RecNum:longint;            { Number of records in file            }
        DataOffset:word;           { First data record's offset into file.}
        RecordLength:integer;      { Record Length                        }
        NumberOfFields:byte;       { Number of fields in each record.     }
                FieldDescrip:TFields;
        dBEOffset : integer; { McQuay Turbo dBase Enhancer Pointer  }
        dBE : boolean;             { McQuay Turbo dBase Enhancer Flag     }
        dbEPtr : pointer;
        dbESize : word;
      end;


        PdbStructure = ^TdbStructure;  { A pointer to a dbStructure       }
        TdbRecord = array[0..2048] of char;

   function db_ptr(var F : file):pointer;
   function db_error  (var errorcode:integer):boolean;
     procedure db_use (dbFileName:TPathName;
                                var FileType;
                                                                var db_Ptr:PdbStructure);
   procedure db_close (var dbfile);
   procedure db_File_Query  (dBFileName:String;
                                                             Var db_Ptr:PdbStructure);
     procedure db_goto(var dbFile; Rec : longint);
     procedure db_read  (var dbfile; var Target);
     procedure db_write  (var dbfile; var Source);
   procedure db_append (var dbfile; var Source);
     procedure db_update_RecNum(var dbfile; Records:longint);
     procedure db_copyfile_structure(OlddbFileName,NewdbFileName:string);
     procedure db_create(dbFileName : string; db : PdbStructure);
     procedure db_dispose_dbptr(var dbptr : PdbStructure);
     procedure dbe_read(var F;var dbeptr:pointer);
     procedure dbe_write(var F;var dbeptr:pointer);
     function db_real(dbAscii:string):real;
     function db_int(dbAscii:string):integer;
     function db_word(dbAscii:string):word;
     function db_longint(dbAscii:string):longint;
     function db_FieldNum(Name:string;var dbf:TdbStructure):word;
   procedure db_date(var dbascii;var day,month,year:word;var error:word);
     function force_dbField(var dbf:TdbStructure;
                          Name:string;FieldType:char;FieldLength:word;
                          FieldInset:word):word;
type
   { Some dBase like field types
     These are not required to use the interface
     But you can use them with your own unltra fast
     routines. }

   db_n1 = char;
   db_n2 = array[1..2] of char;
   db_n3 = array[1..3] of char;
   db_n4 = array[1..4] of char;
   db_n5 = array[1..5] of char;
   db_n6 = array[1..6] of char;
   db_n7 = array[1..7] of char;
   db_n8 = array[1..8] of char;
   db_n9 = array[1..9] of char;
   db_n10 = array[1..10] of char;
   db_r3 = db_n3;
   db_r4 = db_n4;
   db_r5 = db_n5;
   db_r6 = db_n6;
   db_r7 = db_n7;
   db_r8 = db_n8;
   db_r9 = db_n9;
   db_r10 = db_n10;
   db_r11 = array[1..11] of char;
   db_r12 = array[1..12] of char;
   db_r13 = array[1..13] of char;
   db_r14 = array[1..14] of char;
   db_r15 = array[1..15] of char;
   db_c1 = char;
   db_c2 = array[1..2] of char;
   db_c3 = array[1..3] of char;
   db_c4 = array[1..4] of char;
   db_c5 = array[1..5] of char;
   db_c6 = array[1..6] of char;
   db_c7 = array[1..7] of char;
   db_c8 = array[1..8] of char;
   db_c9 = array[1..9] of char;
   db_c10 = array[1..10] of char;
   db_c15 = array[1..15] of char;
   db_c20 = array[1..20] of char;
   db_c25 = array[1..25] of char;
   db_c30 = array[1..30] of char;
   db_c35 = array[1..35] of char;
   db_c40 = array[1..40] of char;
   db_c45 = array[1..80] of char;
   db_datefield = array[1..8] of byte;
   db_memofield = array[1..10] of byte;
implementation

{TURBO DBASE INTERFACE ROUTINES }

  {---------------------------------------------------------------------------}

{   McQuay Turbo-dBase Interface Routines
    Version 1.2
    copyright McQuay Technologies 1986
    7/23/86
    r. quay

    These routines provide the basic structure needed to access dBase II, III,
    and III+ data files.  All of the major routines will work on either a
    dBase II or dBase III file, with out prior knowledge of the version being
    accessed.

{------------------------------------------------------------}
const
  dbptrid : word = $6264;
  dbEID : word = $dbe;
type
  date_header_type = record
       year,month,day:byte;
     end;

  {.............................}
  dbFileHeaderType =  record
      id:byte;
      date: date_header_type;
      RecNum:longint;
      dbOffset:word;
      RecordLength:word;
      gap:array[1..20] of byte;
      end;

  {.............................}
  dbFieldType = record
         Fname : TFieldName;
     ftype : char;
     somefieldoffset:word;
     memaddr : word;
     flength:byte;
     dlength:byte;
     gap2: array[1..14] of byte;
     end;
{------------------------------------------------------------------}
function farparent :pointer;
inline (
         $8B/$46/$02/  { mov ax,[bp+2] }
         $8B/$56/$04); { mov dx,[bp+4] }

function nearparent :pointer;
inline (
         $8C/$CA/      { mov dx,cs        }
         $8B/$46/$02); { mov ax,[bp+2]    }
{------------------------------------------------------------------}
procedure db_RunError(dberr,doserr,dbeerr: word;
                     addr: pointer;
                     message: string);
begin
  db_errorcode := dberr;
  db_doserrorcode := doserr;
  dbe_errorcode := dbeerr;
  if db_ErrorTrap then
    begin
    if message <> '' then
      writeln(message,'  Error codes ',
              db_errorcode:6,db_doserrorcode:6,dbe_errorcode:6);
    FRTError(addr,db_errorcode);
    end;
end;
procedure set_dberror(dberr,doserr,dbeerr:word);
begin
  db_errorcode := dberr;
  db_doserrorcode := doserr;
  dbe_errorcode := dbeerr;
end;
{------------------------------------------------------------}
  function db_error  (var errorcode:integer):boolean;

{  This function can be called to check if an error has been generated
   by a Turbo dBase routine.  Will return false if no error.  Will return
   a true if an error has occured.  errorcode will be the error type as
   follows:   1     = File Not Found
              2 & 3 = Error while readig File Header (Not a dBase file)
              4     = Error in Field Descriptor
              5     = Read past end of file
             11     = Try to Add Duplicate Field Name
   Will reset db_error and errorcode to False and 0 respectively.

   dbE error code
      1 Error during read of Enhanced field
}
begin
  if db_errorcode > 0 then db_error := True
  else db_error := False;
  errorcode := db_errorcode;
  db_errorcode := 0;
end;


{------------------------------------------------------------}
procedure decode_db_FieldType(dbfB:dbFieldType;var dbFD:TFieldDescript);
begin
   with dbFD do
     with dbFB do
       begin
       FieldName := FName;
       Fieldtype := FType;
       FieldLength := FLength;
       Decimals := DLength;
       end;
end;
{----------------------------------------------------------------------}
procedure decode_db_Header(dbhead:dbFileHeaderType;
                            var Adbfile;
                                                        var dbPtr:PdbStructure);
var
  tempid:byte;
  dbfile:file absolute AdbFile;
    ioerror,TempWord : word;
  tempoffset : longint;
  tempmark,i,bytes,offset:word;
  field:dbFieldType;
begin
  tempid := dbhead.id and $f;
  tempMark := 0;
  with dbptr^ do
       begin
       version:=3;
       date.year := dbhead.date.year;
       date.month := dbhead.date.month;
       date.day := dbhead.date.day;
       DataOffset := dbhead.dbOffset;
       RecNum := dbhead.RecNum;
       RecordLength := dbhead.Recordlength;
       { Check if Enhanced File }
       dbE := False;
       dbEPtr := nil;
       dbEsize := 0;
       dbEOffset := 0;
       move(dbhead.gap[1],tempmark,2);
       if tempmark = dbEID then
         begin
                 move(dbhead.gap[3],tempword,2);
                 TempOffset := Tempword;
                 ioerror := absoluteseek(dbfile,tempoffset,tempoffset);
         bytes := 2;
                 ioerror := absoluteread(dbfile,tempmark,bytes,bytes);
                 if ioerror >0 then
                     begin
                     set_dberror(0,ioerror,1);
                     exit;
                     end;
                 if tempmark = dbEID then
                     begin
                     dBE := True;
                     dbEoffset := Tempoffset +2;
                     dbESize := DataOffset - dbEoffset;
                     end;
                 end;
             { Point to Fields }

            ioerror := absoluteseek(dbfile,$20,Tempoffset);
                 if ioerror >0 then
                     begin
                     set_dberror(1,ioerror,0);
                     exit;
                     end;
            { Read Fields }
            i:=0;
            bytes := $20;
            offset :=1;
            repeat
             i:=i+1;

             ioerror := absoluteread(dbfile,field,bytes,bytes);
             if ioerror>0 then
                 if (ioerror<>$26)or(field.Fname[1]<>#13) then
                     begin
                     set_dberror (2,ioerror,0);
                     exit;
           end;

       decode_db_fieldType(field,FieldDescrip[i]);
       FieldDescrip[i].inset := offset;
       offset := offset + FieldDescrip[i].FieldLength;
     until field.Fname[1]=chr($D);
     NumberOfFields := i -1;

     { assign FIB }
     TurboFile := @dbfile;
   end;
end;
{------------------------------------------------------------}
function db_ptr(var F : file):pointer;
{ This routine returns the pointer to the dbStructure for the turbo file F.
  If F has not been opened with db_use, then the pointer is nil.  This
  routine is used mostly as an internal routine for the dbTurbo routines.
  It can also be used as a quick check to see if a file has been opened with
  db_use, check for a nil.}
var
  dbF : filerec absolute F;
  P : pointer;
begin
  if (dbF.UserData[1]=$64)and(dbF.UserData[2]=$62) then
     begin
     move(dbF.UserData[3],P,4);
     db_ptr := P;
     end
  else
    db_ptr := nil;
end;

{------------------------------------------------------------}
procedure install_db_ptr(var F:file;P:pointer);
{ This is an internal dbTurbo routine.  It is used by db_Use to install
  a pointer to the files dbStructure in Turbo's FIB for your convenience. }
var
  dbF : filerec absolute F;
begin
  dbF.UserData[1] := $64;
  dbF.UserData[2] := $62;
  move(P,dbF.UserData[3],4);
end;

{ This routine is used by db_close, to remove the above mentioned pointer. }
procedure uninstall_db_ptr(var F:file);
var
  dbF : filerec absolute F;
begin
  fillchar(dbF.UserData[1],6,0);
end;

{------------------------------------------------------}
procedure dbe_read(var F;var dbeptr:pointer);
var
  afile : file absolute F;
    dbptr : PdbStructure;
    bytes,ioerror : word;
    Fpos:longint;
begin
  dbptr := db_ptr(aFile);
  if dbptr = nil then
    begin
    db_RUNerror (0,0,2,farparent,'File Not Opened with DB_USE');
    exit;
    end
  else
    if not dbptr^.dbE then
      begin
      db_RUNerror (0,0,3,farparent,'dBase File Not Enhanced');
      exit;
      end
    else
      with dbptr^ do
        begin
                ioerror := absoluteseek(afile,dbEoffset,Fpos);
                 if ioerror >0 then
           begin
           db_RUNerror (0,ioerror,4,farparent,'File Read Error');
           exit;
           end;
        if dbEptr = nil then
         if maxavail<dbEsize then
           begin
           db_RUNerror (0,ioerror,5,farparent,
                          'Not enough memory for DBE buffer');
           exit;
           end
         else
           getmem(dbEptr,dbEsize);
        bytes := dbEsize;
                ioerror := absoluteread(afile,dbEptr^,bytes,bytes);
                if ioerror>0 then
                     begin
                     db_RUNerror (0,ioerror,6,farparent,'File Read Error');
                     exit;
                     end;
                end;
end;
{--------------------------------------------------------}
procedure dbe_write(var F;var dbeptr:pointer);
var
  afile : file absolute F;
    Fpos:longint;
    dbptr : PdbStructure;
  bytes,ioerror : word;
  tempdtoffset : word;
  endmark : byte;
begin
  dbptr := db_ptr(aFile);
  if dbptr = nil then
    begin
    db_RUNerror (0,0,7,farparent,'File not opened with DB_USE');
    exit;
    end
  else
    if not dbptr^.dbE then
      begin
      db_RUNerror (0,0,8,farparent,'File not enhanced');
      exit;
      end
    else
      if dbptr^.dbEptr=nil then
        begin
        db_RUNerror (0,0,9,farparent,'Enhanced Pointer is nil');
        exit;
        end
      else
        with dbptr^ do
          begin
                    ioerror := absoluteseek(afile,dbEoffset-2,Fpos);
                    if ioerror>0 then
                        begin
                        db_RUNerror (0,ioerror,10,farparent,'File Seek Error');
                        exit;
                        end;
                    bytes := 2;
                    ioerror := absolutewrite(afile,dbeID,bytes,bytes);
                    bytes := dbEsize;
                    ioerror := absolutewrite(afile,dbEptr^,bytes,bytes);
            endMark := $D;
            ioerror := absolutewrite(afile,endMark,1,bytes);
                    end;
                if ioerror>0 then
          begin
          db_RUNerror (0,ioerror,11,farparent,'File Write Error');
          exit;
          end;
end;

{------------------------------------------------------------}
procedure db_dispose_dbptr(var dbptr : PdbStructure);
var
    db:PdbStructure absolute dbptr;
begin
  with db^ do
    begin
    if dbE and (dbEptr <> nil) then
      freemem(dbEptr,dbEsize);
        if seg(db^)>Dseg then
         freemem(db,sizeof(db^))
        else
            fillchar(db^,sizeof(db^),0);
        end;
end;

{------------------------------------------------------------}
    procedure db_use (dbFileName:TPathName;
                                                                var FileType;
                                                                var db_Ptr:PdbStructure);

{  This proc fopens a dbase file for use by all Turbo dBase Routines.  It
     assigns the file, resets the file, reads the file header, creates a
   dbStructure, and sets the file pointer to the first record.
   If FileType has already been assigned, then this proc begins with a
   reset.  If FileType has already been reset, then it begins by reading
   the file header.  Regardless, on exit the record pointer for FileType
   points to the first data record.  If FileType has not been used in a
     Turbo Pascal ASSIGN and RESET procedure, then only Turbo dBase routines or
   McQuay Extended FileIO routines should be used to read and write to
   this file.  However, if FileType has been used in a Turbo Pascal ASSIGN
   and RESET statement before being passed to this proc, then any of Turbo
   Pascals file IO routines, as well as Turbo dBase and McQuay Extended File IO
   routines, can be used with this file (including BlockRead and BlockWrite!).
     Now that opens a lot of possibilities!
   Use dBerror to check for IO errors.  If an error does occur, FileType
   is closed regardless of who assigned it.
}

 var
    dbfile : file absolute FileType;
    dbptr : PdbStructure absolute db_ptr;
    dbhead : dbFileHeaderType;
    ioerror,bytes:word;
    FPos : longint;
    TempFIB : FileRec;
    err : word;
    errptr :pointer;
    FileStatus:TFileStatus;
begin
    db_errorcode :=0;
    ioerror := 0;
    fillchar(dbhead,sizeof(dbhead),0);
    FileStatus := TurboFileStatus(dbFile);
    if FIleStatus = unknown then
        begin
    assign(dbfile,dbfilename);
        reset(dbfile);
    end;
    if FileStatus = Closed then
        reset(dbfile);
    err := ioresult;
    if err >0 then
        begin
    db_RUNerror (12,err,0,farparent,'File Reset Failure');
    db_close(dbfile);
    db_dispose_dBPtr(db_Ptr);
    exit;
    end;

  bytes := 0;
    ioerror := AbsoluteSeek(FileType,bytes,Fpos);
    { read dbase file header }
    bytes := sizeof(dbhead);
    ioerror := AbsoluteRead(dbfile,dbhead,bytes,bytes);
    err := ioerror;
    if err >0 then
        begin
        db_RUNerror (13,err,0,farparent,'File Read Error');
    db_close(dbfile);
    db_dispose_dBPtr(db_Ptr);
    exit;
    end;

  { get new pointer  }
  if dbPtr = nil then
    if maxavail<sizeof(dbPtr^) then
      begin
      db_RUNerror (14,0,0,farparent,'Not Enough Memory');
      exit;
      end
    else
      new(dbPtr);

  { Put pointer into file structure }
  install_db_ptr(dbfile,dbptr);

  { set filename and status }
  dbPtr^.FileName := dbFileName;
    dbPtr^.Status := TurboFileStatus(FileType);

  { decode header }
  decode_db_Header(dbhead,dbfile,dbPtr);
  if db_errorcode>0 then
    begin
    db_RUNerror (db_errorcode,db_doserrorcode,dbE_errorcode,farparent,
    'Bad File Header');
    exit;
    end;

  { If this is an enhanced file, and dbEnhance flag on, get
    enhanced data }
  if dbEnhance and dbPtr^.dbE then
    with dbptr^ do
      dbe_read(FileType,dbeptr);
  if db_errorcode>0 then
    begin
    db_RUNerror (db_errorcode,db_doserrorcode,dbE_errorcode,
                 farparent,'File Read Error');
    exit;
    end;

  { move file pointer to data }
    ioerror := AbsoluteSeek(FileType,dbPtr^.DataOffset,FPos);
    if ioerror >0 then
        begin
        db_RUNerror (18,ioerror,0,farparent,'File Seek Error');
        db_close(dbfile);
        db_dispose_dBPtr(db_Ptr);
        exit;
        end;
end;

{------------------------------------------------------------}
procedure db_close (var dbfile);
{  Closes a dBase file }

var
  afile : file absolute dbfile;
  textfile : text absolute dbfile;
    dbptr : PdbStructure;
  tpmode : word;
begin
  dbptr := db_ptr(afile);

  { If nil then just ignore call with no error }
  if dbptr = nil then
    exit
  else
    begin
    uninstall_db_ptr(afile);
    { check if enhanced and if so uninstall enhanced data structures }
    with dbptr^ do
      if dbenhance and dbE and (dbEptr<>nil) then
        begin
        freemem(dbEptr,dbEsize);
        dbEsize := 0;
        dbEptr := nil;
        end;
    end;
 { check to see what kind of file it is, if it is a textfile use a textfile
    close, otherewise use a file close.  If already closed the just clean
    up and exit.
 }
  case (turboFilemode(dbfile) and $ff) of
    $B1,$B2 : close(textfile);
    $B3 : close(afile);
    end;

end;

{------------------------------------------------------------}
procedure db_File_Query  (dBFileName:String;  Var db_Ptr:PdbStructure);

{  This proc can be used to examine the structure of a dBase file with
   out opening it for use.  It simply opens the file, reads its header
   and puts it into a dbstructure.  Is used by the db_copyfile_structure()
   routine.
}
 var
  dbfile : file of dbFileHeaderType;
  dbhead : dbFileHeaderType;
    dbptr : PdbStructure absolute db_ptr;
    ioerror,bytes : word;
    Fpos:longint;
begin
  fillchar(dbhead,sizeof(dbhead),0);
  assign(dbfile,dbFileName);
  reset(dbfile);
  if ioresult >0 then
    begin
    db_RUNerror (0,0,19,farparent,'File Reset Error');
    exit;
    end;

  { read dbase file header }
  Read(dbfile,dbhead);
  if ioresult >0 then
    begin
    db_RUNerror (20,0,0,farparent,'File Read Error');
    exit;
    end;

  { get new pointer  }
  if dbPtr = nil then
    new(dbPtr);

  { set filename and status }
  dbPtr^.FileName := dbFileName;
  dbPtr^.Status := unknown;

  { decode header }
  decode_db_Header(dbhead,dbfile,dbPtr);

  { check if enhanced }
  if dbPtr^.dbE and dbEnhance then
    with dbptr^ do
      begin
      getmem(dbEptr,dbEsize);
            ioerror := absoluteseek(dbFile,dbEOffset,FPos);
            bytes := dbESIze;
            ioerror := absoluteread(dbFile,dbEPtr^,bytes,bytes);
            if ioerror >0 then
                begin
                db_RUNerror (0,0,20,farparent,'File Read Error');
                exit;
                end;
            end;
    db_close(dbfile);
end;


{------------------------------------------------------------}
procedure db_goto(var dbFile; Rec : longint);
var
  Afile : file absolute dbfile;
  bytes :longint;
  ioerror: word;
    dbptr : PdbStructure;
  fp : longint;
begin
  if Rec=0 then
    begin
    db_RUNerror (21,0,0,farparent,'Record equals 0');
    exit;
    end;
  dbptr := db_ptr(afile);
  if dbptr = nil then
    begin
    db_RUNerror (22,0,0,farparent,'Pointer is nil');
    exit;
    end;
  bytes := (dbPtr^.RecordLength * (Rec-1)) + dbPtr^.DataOffset;
    ioerror := absoluteseek(afile,bytes,bytes);
    if ioerror > 0 then
        begin
        db_RUNerror (23,0,0,farparent,'File Seek Error');
        exit;
        end;
end;
{------------------------------------------------------------}
procedure db_read  (var dbfile; var Target);


{ This procedure can be used to read a record from a dBase file.  All fields
  of the record for the current location of the file pointer is transfered
  to Target.  The routine does not (can not) check that Target is as large
  as the record length.  Passing a variable to Target that is smaller than
  the record length will have unpredictable results.  This function unlike
  Turbo's READ leaves the file pointer pointing at the record it just read
  rather than at the next record.
}
var
  Afile : file absolute dbfile;
  bytes,ioerror: word;
    dbptr : PdbStructure;
  fp : longint;
begin
  if db_errorcode>0 then exit;
  dbptr := db_ptr(afile);
  if dbptr = nil then
    begin
    db_RUNerror (24,0,0,farparent,'Pointer is nil');
    exit;
    end;
  bytes := dbPtr^.RecordLength;
  fp := absolutefilepos(afile,ioerror);
  if ioerror > 0 then
    begin
    db_RUNerror(25,0,0,farparent,'File Seek Error');
    exit;
    end;
    ioerror := AbsoluteRead(Afile,Target,Bytes,bytes);
  if ioerror > 0 then
    begin
    db_RUNerror(26,0,0,farparent,'File Read Error');
    exit;
    end;
    ioerror := absoluteseek(Afile,fp,fp);
  if ioerror > 0 then
    begin
    db_RUNerror(27,0,0,farparent,'File Seek Error');
    exit;
    end;
end;
{------------------------------------------------------------}
procedure db_write  (var dbfile; var Source);


{ This procedure can be used to write a record to a dBase file.  All fields
  of the record for the current location of the file pointer is transferred
  to Target.  The routine does not (can not) check that Source is as large
  as the record length.  Passing a Source that is smaller than
  the record length will have unpredictable results (i.e. write junk
  to the file).  This function unlike Turbo's WRITE leaves the file pointer
  pointing at the record it just read rather than at the next record.
}
var
  Afile : file absolute dbfile;
  bytes,ioerror: word;
    dbptr : PdbStructure;
  fp : longint;
begin
  if db_errorcode>0 then exit;
  dbptr := db_ptr(afile);
  if dbptr = nil then exit;
  bytes := dbPtr^.RecordLength;
  fp := absolutefilepos(afile,ioerror);
  if ioerror > 0 then
    begin
    db_RUNerror(28,0,0,farparent,'File Seek Error');
    exit;
    end;
    ioerror := Absolutewrite(Afile,Source,Bytes,bytes);
    if ioerror > 0 then
        begin
        db_RUNerror(29,0,0,farparent,'File Write Error');
        exit;
        end;
    ioerror := absoluteseek(Afile,fp,fp);
    if ioerror > 0 then
        begin
        db_RUNerror(30,0,0,farparent,'File Seek Error');
        exit;
        end;
end;
{------------------------------------------------------------}
  procedure db_append (var dbfile; var Source);
   var
     Afile : file absolute dbfile;
     bytes,ioerror: word;
       dbptr : PdbStructure;
     fp : longint;
   begin
   if db_errorcode>0 then exit;
   dbptr := db_ptr(afile);
   if dbptr = nil then exit;
   db_goto(dbfile,dbptr^.Recnum+1);
   db_write(dbfile,Source);
   db_update_RecNum(dbfile,dbptr^.Recnum+1);
   end;

{------------------------------------------------------------}
procedure encode_db_FieldType(var dbfB:dbFieldType;dbFD:TFieldDescript);
procedure place_null(F1:TFieldName;var F2:TFieldName);
var
  i:word;
begin
  i:=1;
  F2 := F1;
  while (f1[i]<>' ')and(i<11) do inc(i);
  F2[i] := char(0);
end;
begin
   with dbFD do
     with dbFB do
       begin
       place_null(FieldName,FName);
       Ftype := Fieldtype;
       Flength := FieldLength;
       Dlength := Decimals;
       fillchar(gap2,sizeof(gap2),0);
       end;
end;
{------------------------------------------------------------}
procedure write_db_Header(var Adbfile;
                                                    var dbptr:TdbStructure);
var
  dbfile:file absolute AdbFile;
  dbhead:dbFileHeaderType;
  ioerror : word;
    tempoffset,fp : longint;
  tempmark : byte;
  i,bytes,offset,y,m,d:word;
  field:dbFieldType;
begin
  dbhead.id :=3;
  tempMark := 0;
  with dbptr do
       begin
       getdate(y,m,d,i);
       dbhead.date.year := y-1900;
       dbhead.date.month := m;
       dbhead.date.day := d;
       dbhead.dbOffset := DataOffset;
       dbhead.RecNum := Recnum;
       dbhead.Recordlength :=RecordLength;
       fillchar(dbhead.gap,sizeof(dbhead.gap),0);
       if DBE and (dbEptr<>nil) then
         begin
         tempmark := dbEoffset -2;
         move(dbEID,dbhead.gap[1],2);
         move(tempmark,dbhead.gap[3],2);
               if dbptr.dataoffset = ((32*(dbptr.NumberOfFields+1))+1) then
                   begin
           dbptr.dbeoffset := dbptr.dataoffset;
           dbptr.dataoffset := dbptr.dataoffset + dbptr.dbEsize +1;
           dbhead.dbOffset := dbptr.DataOffset;
           end;
         end
       else
         fillchar(dbhead.gap,0,sizeof(dbhead.gap));
       end;
     ioerror := absoluteseek(dbfile,0,fp);
    if ioerror > 0 then
        begin
        db_RUNerror(31,0,0,farparent,'File Seek Error');
        exit;
        end;
    bytes := sizeof(dbhead);
    ioerror := absolutewrite(dbfile,dbhead,bytes,bytes);
    if ioerror > 0 then
        begin
        db_RUNerror(31,0,0,farparent,'File Write Error');
        exit;
        end;
     for i:=1 to Dbptr.NumberOfFields do
     begin
     encode_db_fieldtype(field,dbptr.fielddescrip[i]);
         ioerror := absolutewrite(dbfile,field,$20,bytes);
         end;
     tempMark := $D;
     ioerror := absolutewrite(dbfile,tempMark,1,bytes);
     if (dbptr.dbE) and (dbptr.dbEptr<>nil) then
            begin
            dbe_write(dbfile,dbptr.dbEptr);
            end;
    if ioerror > 0 then
        begin
    db_RUNerror(32,0,0,farparent,'File Write Error');
    exit;
    end;
end;


{------------------------------------------------------------}
procedure db_update_RecNum(var dbFile; Records: longint);
var
  Afile : file absolute dbfile;
  bytes,ioerror: word;
    dbptr : PdbStructure;
  fp : longint;
begin
  if db_errorcode>0 then exit;
  dbptr := db_ptr(afile);
  if dbptr = nil then
    begin
    db_RUNerror(34,0,0,farparent,'File not opened with DB_USE');
    exit;
    end;
  fp := absolutefilepos(afile,ioerror);
  dbptr^.recnum := Records;
  write_db_Header(dbfile,dbptr^);
  if db_errorcode > 0 then
    begin
    db_RUNerror(db_errorcode,db_doserrorcode,dbe_errorcode,
                farparent,'Header Update Error');
    exit;
    end;
    ioerror := absoluteseek(Afile,fp,fp);
    if ioerror > 0 then
        begin
        db_RUNerror(35,0,0,farparent,'File Seek Error');
        exit;
        end;
end;

{------------------------------------------------------------}
procedure db_create(dbFileName : string; db : PdbStructure);
{ This routine will create an empty dbase file.  All that needs to
  be passed in the dbstructure is the number of fields and the
  fielddescrip array }
var
  dbfile:file;
  dbF : filerec absolute dbFile;
  P : pointer;
    dbptr : PdbStructure absolute db;
  ioerror : word;
  tempoffset : longint;
  tempmark : byte;
  i,bytes,offset,y,m,d:word;
  field:dbFieldType;
begin

  assign(dbfile,dbFilename);
  rewrite(dbfile);
  ioerror := ioresult;
  if ioerror > 0 then
    begin
    db_RUNerror(33,ioerror,0,farparent,'File Rewrite Failure');
    exit;
    end;
  dbF.UserData[1]:=$64;
  dbF.UserData[2]:=$62;
  move(db,dbF.UserData[3],4);
  with dbptr^ do
    begin
    recnum := 0;
    dataOffset := (32*(NumberOfFields+1))+1;
    RecordLength := 0;
    for i:=1 to NumberOfFields do
      RecordLength := RecordLength +
        FieldDescrip[i].FieldLength;
    inc(RecordLength);
    write_db_header(dbfile,dbptr^);
    end;
  close(dbfile);

end;

{------------------------------------------------------------}
procedure db_copyfile_structure(OlddbFileName,NewdbFileName:string);
var
    newdb,olddb:TdbStructure;
    newdbptr,olddbptr : PdbStructure;
  oldfile,newfile:file;
  ioerror : word;
begin
  newdbptr := @newdb;
  db_File_Query(olddbFileName,newdbptr);
  assign(newfile,NewdbFilename);
  rewrite(newfile);
  ioerror := ioresult;
  if ioerror > 0 then
    begin
    db_RUNerror(33,ioerror,0,farparent,'File Rewrite Failure');
    exit;
    end;
  if newdb.dbE then
    with newdb do
      if (dbEptr = nil) then
        begin
        assign(oldfile,OlddbFilename);
        olddbPtr := @olddb;
        getmem(dbEptr,dbEsize);
        db_use(olddbFilename,oldfile,olddbptr);
        dbe_read(oldfile,dbEptr);
        close(oldfile);
        end;
  write_db_header(newfile,newdb);
  close(newfile);
end;



{------------------------------------------------------------}
function db_real(dbAscii:string):real;

{ This function will convert a dBase ASCII field into a Turbo real type
  value.  Leading spaces are ignored, trailing spaces are fatal.  A field
  with all spaces is translated as a 0 value.  dBError 101 means that this
  function wa unable to translate a value.
  This routine is fairly slow, but requires no "intelligence" about the
  particular field being translated.
}
var
  tempstr:string;
  i,j,k,l:integer;
  tempreal:real;
begin
  j:=length(dbAscii);
  i:=1;
  while (dbAscii[i]=#32)and(i<j) do
    i:=i+1;
  k:=1;
  while (i<=j) do
    begin
    tempstr[k] := dbAscii[i];
    i:=i +1;
    k:= k+1;
    end;
  tempstr[0] := chr(k-1);
  val(tempstr,tempreal,k);
  if (k=0)or(k=j) then
    db_real := tempreal
  else
    begin
    db_real := 0;
    db_RUNerror(101,0,0,farparent,'Can not Evaluate Field');
    end;
end;

{------------------------------------------------------------}
function db_int(dbAscii:string):integer;

{ This function will convert a dBase ASCII field into a Turbo integer type
  value.  Leading spaces are ignored, trailing spaces are fatal.  A field
  with all spaces is translated as a 0 value.  dBError 13 means that this
  function wa unable to translate a value.
}
var
  tempstr:string;
  i,j,k,l:integer;
  temp:integer;
begin
  j:=length(dbAscii);
  i:=1;
  while (dbAscii[i]=#32)and(i<j) do
    i:=i+1;
  k:=1;
  while (i<=j) do
    begin
    tempstr[k] := dbAscii[i];
    i:=i +1;
    k:= k+1;
    end;
  tempstr[0] := chr(k-1);
  val(tempstr,temp,k);
  if (k=0)or(k=j) then
    db_int := temp
  else
    begin
    db_int := 0;
    db_RUNerror(101,0,0,farparent,'Can not Evaluate Field');
    end;
end;
{------------------------------------------------------------}
function db_word(dbAscii:string):word;

{ This function will convert a dBase ASCII field into a Turbo word type
  value.  Leading spaces are ignored, trailing spaces are fatal.  A field
  with all spaces is translated as a 0 value.  dBError 101 means that this
  function wa unable to translate a value.
}
var
  tempstr:string;
  i,j,k,l:integer;
  temp:word;
begin
  j:=length(dbAscii);
  i:=1;
  while (dbAscii[i]=#32)and(i<j) do
    i:=i+1;
  k:=1;
  while (i<=j) do
    begin
    tempstr[k] := dbAscii[i];
    i:=i +1;
    k:= k+1;
    end;
  tempstr[0] := chr(k-1);
  val(tempstr,temp,k);
  if (k=0)or(k=j) then
    db_word := temp
  else
    begin
    db_word := 0;
    db_RUNerror(101,0,0,farparent,'Can not Evaluate Field');
    end;
end;
{------------------------------------------------------------}
function db_longint(dbAscii:string):longint;

{ This function will convert a dBase ASCII field into a Turbo word type
  value.  Leading spaces are ignored, trailing spaces are fatal.  A field
  with all spaces is translated as a 0 value.  dBError 101 means that this
  function wa unable to translate a value.
}
var
  tempstr:string;
  i,j,k,l:integer;
  temp:longint;
begin
  j:=length(dbAscii);
  i:=1;
  while (dbAscii[i]=#32)and(i<j) do
    i:=i+1;
  k:=1;
  while (i<=j) do
    begin
    tempstr[k] := dbAscii[i];
    i:=i +1;
    k:= k+1;
    end;
  tempstr[0] := chr(k-1);
  val(tempstr,temp,k);
  if (k=0)or(k=j) then
    db_longint := temp
  else
    begin
    db_longint := 0;
    db_RUNerror(101,0,0,farparent,'Can not Evaluate Field');
    end;
end;
{**************************************************************}
procedure db_date(var dbascii;var day,month,year:word;var error:word);
var
    i,j:word;
    temp:string;
    d:array[1..8] of char absolute dbascii;
begin
    day := 0;
    month := 0;
    year := 0;
    move(d[1],temp[1],4);
    temp[0]:=#4;
    val(temp,i,error);
    if error>0 then exit;
    year := i;
    move(d[5],temp[1],2);
    temp[0]:=#2;
    val(temp,i,error);
    if error>0 then exit;
    month := i;
    move(d[7],temp[1],2);
    temp[0]:=#2;
    val(temp,i,error);
    if error>0 then exit;
    day := i;
end;

function db_FieldNum(Name:string;var dbf:TdbStructure):word;
var
    i,j,k:word;
    found:boolean;
    temp : array[1..11] of char;
begin
    k:=length(Name);
    if k>11 then k:=11;
    j:=0;
    for i:=1 to k do
        if Name[i] in ['#','0'..'z'] then
            begin
            inc(j);
            temp[j]:=upcase(Name[i]);
            end;
    k:=j;
    i:=0;
    repeat
        inc(i);
        found := true;
        j:=0;
        repeat
            inc(j);
            found :=  (dbf.fieldDescrip[i].fieldname[j] = temp[j]) ;
        until (not found) or (j=k);
        if found and ((j=11) or (dbf.fieldDescrip[i].fieldname[j+1]  = #0)) then
            found := true
        else
            found := false;

    until found or (i=dbf.NumberOfFields);
    if found then
    db_FieldNum := i
  else
    db_FieldNum := 0;
end;

  {****************************************************************}
    function force_dbField(var dbf:TdbStructure;
                          Name:string;FieldType:char;FieldLength:word;
                          FieldInset:word):word;
  var
    i:word;
  begin
    if db_errorcode>0 then exit;
    with dbf do
      begin
      if numberOfFields = MaxFields then
        begin
        db_RUNerror(0,0,14,farparent,'To Many Fields to Force New Field');
        exit;
        Force_dbField := 0;
        end;
      inc(NumberOfFields);
      i:=1;
      while (Name[i] in ['#','0'..'9','A'..'Z','a'..'z'])and(i<12) do
        begin
        fielddescrip[NumberOfFields].FieldName[i] := Name[i];
        inc(i);
        end;
      if i=1 then
        begin
        db_RUNerror(0,0,14,farparent,'Bad FieldName');
        exit;
        end;
      while i<12 do
        begin
        fielddescrip[NumberOfFields].FieldName[i] := #0;
        inc(i);
        end;
      fielddescrip[NumberOfFields].FieldType := FieldType;
      fielddescrip[NumberOfFields].FieldLength := FieldLength;
      fielddescrip[NumberOfFields].inset := Fieldinset;
      fielddescrip[NumberOfFields].Decimals := 0;
      force_dbField := NumberOfFields;
      end;
  end;
end.